home *** CD-ROM | disk | FTP | other *** search
/ Delphi Informant Complete 1995 - 2000 / Delphi Informant Complete 1995 to 2000.iso / Delphi Informant Magazine Complete Works SOURCE CODE 1998.rar / 1998 / Feb / di9802kw / WPLoad1.pas < prev   
Pascal/Delphi Source File  |  1997-08-22  |  4KB  |  129 lines
  1. unit WPLoad1;
  2.  
  3. {
  4.   Allow JPEG and GIF files to be loaded into the WebPics database.
  5.  
  6.   Written by Keith Wood, 21 August, 1997.
  7. }
  8.  
  9. interface
  10.  
  11. uses
  12.   Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
  13.   ExtCtrls, DBCtrls, Db, StdCtrls, Buttons, Grids, DBGrids, DBTables,
  14.   FileCtrl;
  15.  
  16. type
  17.   TfrmLoadWebPics = class(TForm)
  18.     flbFiles: TFileListBox;
  19.     fltFilter: TFilterComboBox;
  20.     dlbDirectories: TDirectoryListBox;
  21.     drvDrives: TDriveComboBox;
  22.     Label1: TLabel;
  23.     edtDescription: TEdit;
  24.     dbgWebPics: TDBGrid;
  25.     btnClose: TBitBtn;
  26.     btnInsert: TBitBtn;
  27.     btnDelete: TBitBtn;
  28.     tblWebPics: TTable;
  29.     tblWebPicsPicture_no: TAutoIncField;
  30.     tblWebPicsPicture_text: TStringField;
  31.     tblWebPicsPicture_type: TStringField;
  32.     tblWebPicsPicture_blob: TBlobField;
  33.     dtsWebPics: TDataSource;
  34.     procedure flbFilesChange(Sender: TObject);
  35.     procedure dtsWebPicsDataChange(Sender: TObject; Field: TField);
  36.     procedure btnCloseClick(Sender: TObject);
  37.     procedure btnInsertClick(Sender: TObject);
  38.     procedure btnDeleteClick(Sender: TObject);
  39.   private
  40.     { Private declarations }
  41.   public
  42.     { Public declarations }
  43.   end;
  44.  
  45. var
  46.   frmLoadWebPics: TfrmLoadWebPics;
  47.  
  48. implementation
  49.  
  50. {$R *.DFM}
  51.  
  52. { Dis/enable insert button }
  53. procedure TfrmLoadWebPics.flbFilesChange(Sender: TObject);
  54. begin
  55.   btnInsert.Enabled := (flbFiles.FileName <> '') and (edtDescription.Text <> '');
  56. end;
  57.  
  58. { Dis/enable delete button }
  59. procedure TfrmLoadWebPics.dtsWebPicsDataChange(Sender: TObject; Field: TField);
  60. begin
  61.   btnDelete.Enabled := (tblWebPics.FieldByName('PICTURE_NO').AsString <> '');
  62. end;
  63.  
  64. { Close the form }
  65. procedure TfrmLoadWebPics.btnCloseClick(Sender: TObject);
  66. begin
  67.   Close;
  68. end;
  69.  
  70. { Add a new record with the contents of the current file }
  71. procedure TfrmLoadWebPics.btnInsertClick(Sender: TObject);
  72. var
  73.   stmPicture: TFileStream;
  74.   stmBlob: TBlobStream;
  75.   stmHeader: TStringStream;
  76.   bDone: Boolean;
  77. begin
  78.   bDone := False;
  79.   with tblWebPics do
  80.     while not bDone do  { Sometimes BlobStream.Create fails so keep trying }
  81.     begin
  82.       Insert;
  83.       stmPicture := TFileStream.Create(flbFiles.FileName, fmOpenRead);
  84.       try
  85.         try
  86.           stmBlob := TBlobStream.Create(TBlobField(FieldByName('PICTURE_BLOB')), bmWrite);
  87.           try
  88.             stmBlob.CopyFrom(stmPicture, 0);
  89.             try
  90.               stmHeader := TStringStream.Create('');
  91.               stmHeader.CopyFrom(stmPicture, 0);
  92.               if Pos('JFIF', stmHeader.DataString) = 7 then
  93.                 FieldByName('PICTURE_TYPE').AsString := 'image/jpeg'
  94.               else if Pos('GIF', stmHeader.DataString) = 1 then
  95.                 FieldByName('PICTURE_TYPE').AsString := 'image/gif'
  96.               else
  97.               begin
  98.                 MessageDlg('Unknown file type - not saved', mtError, [mbOK], 0);
  99.                 Abort;
  100.               end;
  101.               FieldByName('PICTURE_TEXT').AsString := edtDescription.Text;
  102.               Post;
  103.               edtDescription.Text := '';
  104.               bDone := True;
  105.             finally
  106.               stmHeader.Free;
  107.             end;
  108.           finally
  109.             stmBlob.Free;
  110.           end;
  111.         except  { Ignore }
  112.         end;
  113.       finally
  114.         stmPicture.Free;
  115.         Cancel;
  116.       end;
  117.     end;
  118. end;
  119.  
  120. { Delete the current record }
  121. procedure TfrmLoadWebPics.btnDeleteClick(Sender: TObject);
  122. begin
  123.   if MessageDlg('Confirm deletion of ' + tblWebPics.FieldByName('PICTURE_TEXT').AsString + '?',
  124.       mtConfirmation, [mbYes, mbNo], 0) = mrYes then
  125.     tblWebPics.Delete;
  126. end;
  127.  
  128. end.
  129.